home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / prim / cleantree.el.z / cleantree.el
Encoding:
Text File  |  1998-05-21  |  2.3 KB  |  69 lines
  1. ;;; cleantree.el --- Remove out of date .elcs in lisp directories
  2.  
  3. ;; Copyright (C) 1997 by Free Software Foundation, Inc.
  4.  
  5. ;; Author: Steven L Baur <steve@altair.xemacs.org>
  6. ;; Keywords: internal
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23. ;; 02111-1307, USA.
  24.  
  25. ;;; Synched up with: Not in FSF
  26.  
  27. ;;; Commentary:
  28.  
  29. ;; This code is derived from Gnus based on a suggestion by
  30. ;;  David Moore <dmoore@ucsd.edu>
  31.  
  32. ;;; Code:
  33.  
  34. (defun remove-old-elc-1 (dir &optional seen)
  35.   (setq dir (file-name-as-directory dir))
  36.   ;; Only scan this sub-tree if we haven't been here yet.
  37.   (unless (member (file-truename dir) seen)
  38.     (push (file-truename dir) seen)
  39.     ;; We descend recursively
  40.     (let ((dirs (directory-files dir t nil t))
  41.           dir)
  42.       (while (setq dir (pop dirs))
  43.         (when (and (not (member (file-name-nondirectory dir) '("." "..")))
  44.                    (file-directory-p dir))
  45.           (remove-old-elc-1 dir seen))))
  46.     ;; Do this directory.
  47.     (let ((files (directory-files dir t ".el$"))
  48.       file file-c)
  49.       (while (setq file (car files))
  50.     (setq files (cdr files))
  51.     (setq file-c (concat file "c"))
  52.     (when (and (file-exists-p file-c)
  53.            (file-newer-than-file-p file file-c))
  54.       (message file-c)
  55.       (delete-file file-c))))))
  56.  
  57. ;;;###autoload
  58. (defun batch-remove-old-elc ()
  59.   (defvar command-line-args-left)
  60.   (unless noninteractive
  61.     (error "`batch-remove-old-elc' is to be used only with -batch"))
  62.   (let ((dir (car command-line-args-left)))
  63.     (message "Cleaning out of date .elcs in directory `%s'..." dir)
  64.     (remove-old-elc-1 dir)
  65.     (message "Cleaning out of date .elcs in directory `%s'...done" dir))
  66.   (setq command-line-args-left nil))
  67.  
  68. ;;; cleantree.el ends here
  69.